home *** CD-ROM | disk | FTP | other *** search
/ 100 Best Shareware & Freeware Games / 100 Games.iso / Cards / PySol / pysol460.exe / {app} / python / DLLs / tk8.3 / tk.tcl < prev    next >
Encoding:
Text File  |  2001-07-27  |  10.1 KB  |  357 lines
  1. # tk.tcl --
  2. #
  3. # Initialization script normally executed in the interpreter for each
  4. # Tk-based application.  Arranges class bindings for widgets.
  5. #
  6. # RCS: @(#) $Id: tk.tcl,v 1.20 2000/03/24 19:38:57 ericm Exp $
  7. #
  8. # Copyright (c) 1992-1994 The Regents of the University of California.
  9. # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  10. # Copyright (c) 1998-2000 Scriptics Corporation.
  11. #
  12. # See the file "license.terms" for information on usage and redistribution
  13. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14.  
  15. # Insist on running with compatible versions of Tcl and Tk.
  16.  
  17. package require -exact Tk 8.3
  18. package require -exact Tcl 8.3
  19. package require Img 1.2
  20.  
  21. # Add Tk's directory to the end of the auto-load search path, if it
  22. # isn't already on the path:
  23.  
  24. if {[info exists auto_path] && [string compare {} $tk_library] && \
  25.     [lsearch -exact $auto_path $tk_library] < 0} {
  26.     lappend auto_path $tk_library
  27. }
  28.  
  29. # Turn off strict Motif look and feel as a default.
  30.  
  31. set tk_strictMotif 0
  32.  
  33. # Create a ::tk namespace
  34.  
  35. namespace eval ::tk {
  36. }
  37.  
  38. # ::tk::PlaceWindow --
  39. #   place a toplevel at a particular position
  40. # Arguments:
  41. #   toplevel    name of toplevel window
  42. #   ?placement?    pointer ?center? ; places $w centered on the pointer
  43. #        widget widgetPath ; centers $w over widget_name
  44. #        defaults to placing toplevel in the middle of the screen
  45. #   ?anchor?    center or widgetPath
  46. # Results:
  47. #   Returns nothing
  48. #
  49. proc ::tk::PlaceWindow {w {place ""} {anchor ""}} {
  50.     wm withdraw $w
  51.     update idletasks
  52.     set checkBounds 1
  53.     if {[string equal -len [string length $place] $place "pointer"]} {
  54.     ## place at POINTER (centered if $anchor == center)
  55.     if {[string equal -len [string length $anchor] $anchor "center"]} {
  56.         set x [expr {[winfo pointerx $w]-[winfo reqwidth $w]/2}]
  57.         set y [expr {[winfo pointery $w]-[winfo reqheight $w]/2}]
  58.     } else {
  59.         set x [winfo pointerx $w]
  60.         set y [winfo pointery $w]
  61.     }
  62.     } elseif {[string equal -len [string length $place] $place "widget"] && \
  63.         [winfo exists $anchor] && [winfo ismapped $anchor]} {
  64.     ## center about WIDGET $anchor, widget must be mapped
  65.     set x [expr {[winfo rootx $anchor] + \
  66.         ([winfo width $anchor]-[winfo reqwidth $w])/2}]
  67.     set y [expr {[winfo rooty $anchor] + \
  68.         ([winfo height $anchor]-[winfo reqheight $w])/2}]
  69.     } else {
  70.     set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}]
  71.     set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}]
  72.     set checkBounds 0
  73.     }
  74.     if {$checkBounds} {
  75.     if {$x < 0} {
  76.         set x 0
  77.     } elseif {$x > ([winfo screenwidth $w]-[winfo reqwidth $w])} {
  78.         set x [expr {[winfo screenwidth $w]-[winfo reqwidth $w]}]
  79.     }
  80.     if {$y < 0} {
  81.         set y 0
  82.     } elseif {$y > ([winfo screenheight $w]-[winfo reqheight $w])} {
  83.         set y [expr {[winfo screenheight $w]-[winfo reqheight $w]}]
  84.     }
  85.     }
  86.     wm geometry $w +$x+$y
  87.     wm deiconify $w
  88. }
  89.  
  90. # ::tk::SetFocusGrab --
  91. #   swap out current focus and grab temporarily (for dialogs)
  92. # Arguments:
  93. #   grab    new window to grab
  94. #   focus    window to give focus to
  95. # Results:
  96. #   Returns nothing
  97. #
  98. proc ::tk::SetFocusGrab {grab {focus {}}} {
  99.     set index "$grab,$focus"
  100.     upvar ::tk::FocusGrab($index) data
  101.  
  102.     lappend data [focus]
  103.     set oldGrab [grab current $grab]
  104.     lappend data $oldGrab
  105.     if {[winfo exists $oldGrab]} {
  106.     lappend data [grab status $oldGrab]
  107.     }
  108.     grab $grab
  109.     if {[winfo exists $focus]} {
  110.     focus $focus
  111.     }
  112. }
  113.  
  114. # ::tk::RestoreFocusGrab --
  115. #   restore old focus and grab (for dialogs)
  116. # Arguments:
  117. #   grab    window that had taken grab
  118. #   focus    window that had taken focus
  119. #   destroy    destroy|withdraw - how to handle the old grabbed window
  120. # Results:
  121. #   Returns nothing
  122. #
  123. proc ::tk::RestoreFocusGrab {grab focus {destroy destroy}} {
  124.     set index "$grab,$focus"
  125.     foreach {oldFocus oldGrab oldStatus} $::tk::FocusGrab($index) { break }
  126.     unset ::tk::FocusGrab($index)
  127.  
  128.     catch {focus $oldFocus}
  129.     grab release $grab
  130.     if {[string equal $destroy "withdraw"]} {
  131.     wm withdraw $grab
  132.     } else {
  133.     destroy $grab
  134.     }
  135.     if {[winfo exists $oldGrab] && [winfo ismapped $oldGrab]} {
  136.     if {[string equal $oldStatus "global"]} {
  137.         grab -global $oldGrab
  138.     } else {
  139.         grab $oldGrab
  140.     }
  141.     }
  142. }
  143.  
  144. # tkScreenChanged --
  145. # This procedure is invoked by the binding mechanism whenever the
  146. # "current" screen is changing.  The procedure does two things.
  147. # First, it uses "upvar" to make global variable "tkPriv" point at an
  148. # array variable that holds state for the current display.  Second,
  149. # it initializes the array if it didn't already exist.
  150. #
  151. # Arguments:
  152. # screen -        The name of the new screen.
  153.  
  154. proc tkScreenChanged screen {
  155.     set x [string last . $screen]
  156.     if {$x > 0} {
  157.     set disp [string range $screen 0 [expr {$x - 1}]]
  158.     } else {
  159.     set disp $screen
  160.     }
  161.  
  162.     uplevel #0 upvar #0 tkPriv.$disp tkPriv
  163.     global tkPriv
  164.     global tcl_platform
  165.  
  166.     if {[info exists tkPriv]} {
  167.     set tkPriv(screen) $screen
  168.     return
  169.     }
  170.     array set tkPriv {
  171.     activeMenu    {}
  172.     activeItem    {}
  173.     afterId        {}
  174.     buttons        0
  175.     buttonWindow    {}
  176.     dragging    0
  177.     focus        {}
  178.     grab        {}
  179.     initPos        {}
  180.     inMenubutton    {}
  181.     listboxPrev    {}
  182.     menuBar        {}
  183.     mouseMoved    0
  184.     oldGrab        {}
  185.     popup        {}
  186.     postedMb    {}
  187.     pressX        0
  188.     pressY        0
  189.     prevPos        0
  190.     selectMode    char
  191.     }
  192.     set tkPriv(screen) $screen
  193.     set tkPriv(tearoff) [string equal $tcl_platform(platform) "unix"]
  194.     set tkPriv(window) {}
  195. }
  196.  
  197. # Do initial setup for tkPriv, so that it is always bound to something
  198. # (otherwise, if someone references it, it may get set to a non-upvar-ed
  199. # value, which will cause trouble later).
  200.  
  201. tkScreenChanged [winfo screen .]
  202.  
  203. # tkEventMotifBindings --
  204. # This procedure is invoked as a trace whenever tk_strictMotif is
  205. # changed.  It is used to turn on or turn off the motif virtual
  206. # bindings.
  207. #
  208. # Arguments:
  209. # n1 - the name of the variable being changed ("tk_strictMotif").
  210.  
  211. proc tkEventMotifBindings {n1 dummy dummy} {
  212.     upvar $n1 name
  213.     
  214.     if {$name} {
  215.     set op delete
  216.     } else {
  217.     set op add
  218.     }
  219.  
  220.     event $op <<Cut>> <Control-Key-w>
  221.     event $op <<Copy>> <Meta-Key-w> 
  222.     event $op <<Paste>> <Control-Key-y>
  223. }
  224.  
  225. #----------------------------------------------------------------------
  226. # Define common dialogs on platforms where they are not implemented 
  227. # using compiled code.
  228. #----------------------------------------------------------------------
  229.  
  230. if {[string equal [info commands tk_chooseColor] ""]} {
  231.     proc tk_chooseColor {args} {
  232.     return [eval tkColorDialog $args]
  233.     }
  234. }
  235. if {[string equal [info commands tk_getOpenFile] ""]} {
  236.     proc tk_getOpenFile {args} {
  237.     if {$::tk_strictMotif} {
  238.         return [eval tkMotifFDialog open $args]
  239.     } else {
  240.         return [eval ::tk::dialog::file::tkFDialog open $args]
  241.     }
  242.     }
  243. }
  244. if {[string equal [info commands tk_getSaveFile] ""]} {
  245.     proc tk_getSaveFile {args} {
  246.     if {$::tk_strictMotif} {
  247.         return [eval tkMotifFDialog save $args]
  248.     } else {
  249.         return [eval ::tk::dialog::file::tkFDialog save $args]
  250.     }
  251.     }
  252. }
  253. if {[string equal [info commands tk_messageBox] ""]} {
  254.     proc tk_messageBox {args} {
  255.     return [eval tkMessageBox $args]
  256.     }
  257. }
  258. if {[string equal [info command tk_chooseDirectory] ""]} {
  259.     proc tk_chooseDirectory {args} {
  260.     return [eval ::tk::dialog::file::chooseDir::tkChooseDirectory $args]
  261.     }
  262. }
  263.     
  264. #----------------------------------------------------------------------
  265. # Define the set of common virtual events.
  266. #----------------------------------------------------------------------
  267.  
  268. switch $tcl_platform(platform) {
  269.     "unix" {
  270.     event add <<Cut>> <Control-Key-x> <Key-F20> 
  271.     event add <<Copy>> <Control-Key-c> <Key-F16>
  272.     event add <<Paste>> <Control-Key-v> <Key-F18>
  273.     event add <<PasteSelection>> <ButtonRelease-2>
  274.     # Some OS's define a goofy (as in, not <Shift-Tab>) keysym
  275.     # that is returned when the user presses <Shift-Tab>.  In order for
  276.     # tab traversal to work, we have to add these keysyms to the 
  277.     # PrevWindow event.
  278.     # The info exists is necessary, because tcl_platform(os) doesn't
  279.     # exist in safe interpreters.
  280.     if {[info exists tcl_platform(os)]} {
  281.         switch $tcl_platform(os) {
  282.         "IRIX"  -
  283.         "Linux" { event add <<PrevWindow>> <ISO_Left_Tab> }
  284.         "HP-UX" { event add <<PrevWindow>> <hpBackTab> }
  285.         }
  286.     }
  287.     trace variable tk_strictMotif w tkEventMotifBindings
  288.     set tk_strictMotif $tk_strictMotif
  289.     }
  290.     "windows" {
  291.     event add <<Cut>> <Control-Key-x> <Shift-Key-Delete>
  292.     event add <<Copy>> <Control-Key-c> <Control-Key-Insert>
  293.     event add <<Paste>> <Control-Key-v> <Shift-Key-Insert>
  294.     event add <<PasteSelection>> <ButtonRelease-2>
  295.     }
  296.     "macintosh" {
  297.     event add <<Cut>> <Control-Key-x> <Key-F2> 
  298.     event add <<Copy>> <Control-Key-c> <Key-F3>
  299.     event add <<Paste>> <Control-Key-v> <Key-F4>
  300.     event add <<PasteSelection>> <ButtonRelease-2>
  301.     event add <<Clear>> <Clear>
  302.     }
  303. }
  304.  
  305. # ----------------------------------------------------------------------
  306. # Read in files that define all of the class bindings.
  307. # ----------------------------------------------------------------------
  308.  
  309. if {[string compare $tcl_platform(platform) "macintosh"] && \
  310.     [string compare {} $tk_library]} {
  311.     source [file join $tk_library button.tcl]
  312.     source [file join $tk_library entry.tcl]
  313.     source [file join $tk_library listbox.tcl]
  314.     source [file join $tk_library menu.tcl]
  315.     source [file join $tk_library scale.tcl]
  316.     source [file join $tk_library scrlbar.tcl]
  317.     source [file join $tk_library text.tcl]
  318. }
  319.  
  320. # ----------------------------------------------------------------------
  321. # Default bindings for keyboard traversal.
  322. # ----------------------------------------------------------------------
  323.  
  324. event add <<PrevWindow>> <Shift-Tab>
  325. bind all <Tab> {tkTabToWindow [tk_focusNext %W]}
  326. bind all <<PrevWindow>> {tkTabToWindow [tk_focusPrev %W]}
  327.  
  328. # tkCancelRepeat --
  329. # This procedure is invoked to cancel an auto-repeat action described
  330. # by tkPriv(afterId).  It's used by several widgets to auto-scroll
  331. # the widget when the mouse is dragged out of the widget with a
  332. # button pressed.
  333. #
  334. # Arguments:
  335. # None.
  336.  
  337. proc tkCancelRepeat {} {
  338.     global tkPriv
  339.     after cancel $tkPriv(afterId)
  340.     set tkPriv(afterId) {}
  341. }
  342.  
  343. # tkTabToWindow --
  344. # This procedure moves the focus to the given widget.  If the widget
  345. # is an entry, it selects the entire contents of the widget.
  346. #
  347. # Arguments:
  348. # w - Window to which focus should be set.
  349.  
  350. proc tkTabToWindow {w} {
  351.     if {[string equal [winfo class $w] Entry]} {
  352.     $w selection range 0 end
  353.     $w icursor end
  354.     }
  355.     focus $w
  356. }
  357.